home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 January - Disc 2 / Macworld (1999-01) (Disk 2).dmg / Serious Demos / Symbolic Composer 4.2 / Environment / Projects / Contributed Scores / Peter Stone Punctus / Bridge < prev    next >
Lisp/Scheme  |  1998-10-26  |  10KB  |  273 lines
  1. (def-orchestra 'orchestra
  2.    piano (lefthand righthand 3rd-voice)
  3. )
  4.  
  5. (defun filter-harmonize2 (mel1 mel2 mod-val tonality n-control s-values)
  6.   (diagnostic2 "filter-harmonize" $cr$)
  7.   (setq mel1 (symbol-trim (length mel2) mel1))
  8.   (prog (out1 out2 gap swap counter n n-times n-count n-values s-master semitones
  9.               maptable)
  10.     (setq maptable (build-maptable (car tonality)))
  11.     (setq counter 0)
  12.     (setq swap t)
  13.     (setq s-master s-values)
  14.     (setq semitones (car s-master))
  15.     (setq n-values n-control)
  16.     (setq n (caar n-values))
  17.     (setq n-times (cadar n-values))
  18.     (setq n-count 0)
  19.     loop
  20.     (cond ((null mel2) (return (list (nreverse out2) (nreverse out1)))))
  21.     (cond ((= counter n)
  22.            (setq counter 0)
  23.            (setq n-count (1+ n-count))
  24.            (setq swap (not swap))))
  25.     (setq counter (1+ counter))
  26.     (cond ((= n-count n-times)
  27.            (setq s-master (cdr s-master))
  28.            (when (null s-master)
  29.              (setq s-master s-values))
  30.            (setq semitones (car s-master))
  31.            (setq n-count 0)
  32.            (setq n-values (cdr n-values))
  33.            (when (null n-values)
  34.              (setq n-values n-control))
  35.            (setq n (caar n-values))
  36.            (setq n-times (cadar n-values))))
  37.     (if swap
  38.       (cond ((or (equal (car mel1) '=) (equal (car mel2) '=))
  39.              (push (car mel1) out2)
  40.              (push (car mel2) out1))
  41.             (t (setq gap (abs (- (symbol-to-mapped-integer (car mel1) maptable)
  42.                                  (symbol-to-mapped-integer (car mel2) maptable))))
  43.                (cond ((member (mod gap mod-val) semitones)
  44.                       (push (closest-harmony (symbol-to-mapped-integer (car mel2) maptable)
  45.                                              (symbol-to-mapped-integer (car mel1) maptable)
  46.                                              (car mel1) (car mel2))
  47.                             out1)
  48.                       (push (car mel1) out2))
  49.                      (t (push (car mel2) out1)
  50.                         (push (car mel1) out2)))))
  51.       (cond ((or (equal (car mel1) '=) (equal (car mel2) '=))
  52.              (push (car mel2) out1)
  53.              (push (car mel1) out2))
  54.             (t (setq gap (abs (- (symbol-to-mapped-integer (car mel1) maptable)
  55.                                  (symbol-to-mapped-integer (car mel2) maptable))))
  56.                (cond ((member (mod gap mod-val) semitones)
  57.                       (push (closest-harmony (symbol-to-mapped-integer (car mel1) maptable)
  58.                                              (symbol-to-mapped-integer (car mel2) maptable)
  59.                                              (car mel2) (car mel1))
  60.                             out2)
  61.                       (push (car mel2) out1))
  62.                      (t (push (car mel1) out2)
  63.                         (push (car mel2) out1))))))
  64.     (pop mel1) 
  65.     (pop mel2)
  66.     (go loop)))
  67.  
  68. (defun closest-harmony (m1 m2 s1 s2)
  69.   (if (> (get-random 0 10) 5)
  70.         '=
  71.         (integer-to-symbol (+ (symbol-to-integer s2) 3))))
  72.  
  73. (defun symbol-mod (n offset s)
  74.   (if (equal s '=)
  75.     '=
  76.     (if (< (symbol-to-integer s) n)
  77.       s
  78.       (integer-to-symbol (+ offset (mod (symbol-to-integer s) n))))))
  79.  
  80. (defun symbol-fold (n offset s)
  81.   (mapcar #'(lambda (x) (symbol-mod n offset x)) s))
  82.  
  83. ; (symbol-fold 14 7 '(a b c d e f g h i j k l m n o p q r s t u v))
  84.  
  85. (defun make-tr-melody (mel repeat trpat sign)
  86.   (let ((out nil)
  87.         (master-tr trpat)
  88.         (trval nil))
  89.     (dotimes (i (length trpat))
  90.       (setq trval (car master-tr))
  91.       (setq master-tr (cdr master-tr))
  92.       (if (null master-tr) (setq master-tr trpat))
  93.       (dotimes (j repeat)
  94.         (push (symbol-transpose trval (symbol-scroll (* sign i) mel)) out)))
  95.     (flatten (nreverse out))))
  96.  
  97. (def-grammar 'progression
  98.   a (a b d)
  99.   b (-c -b a)
  100. )
  101.  
  102. (setq seedpat1 (symbol-trim 32 (gen-trans a 4 'progression)))
  103. (setq seedpat2 (symbol-inversion 'e seedpat1))
  104. (setq seedpat3 (symbol-trim 32 (gen-trans b 3 'progression)))
  105.  
  106. (mapcar #'symbol-to-integer seedpat1)
  107.  
  108. (setq transpat (mapcar #'symbol-to-integer seedpat1))
  109. (setq transpat2 (mapcar #'symbol-to-integer seedpat2))
  110. (setq transpat3 (mapcar #'symbol-to-integer seedpat3))
  111.  
  112. (setq melody-1 (symbol-fold 14 7 (make-tr-melody seedpat1 2 transpat2 1)))
  113. (setq melody-2 (symbol-fold 14 7 (make-tr-melody seedpat2 2 transpat2 -1)))
  114.  
  115. (setq tempo-zone-len (/ (get-ratio '12/1 :ratio)
  116.                         (get-ratio '1/8 :ratio)))
  117.  
  118. (setq tempomap1 (gen-fourier 
  119.                       (gen-random 0.479123 5 '(1 2 3 5 8)) ; frequencies
  120.                       '(0.6 0.2 (gen-sin 10 0.22 64) 0.2) ; amplitudes
  121.                       '(0 45 90) ; initial phases
  122.                       tempo-zone-len))
  123.  
  124. (setq tempomap2 (gen-fourier 
  125.                       (gen-random 0.491237 5 '(1 2 3 5 8)) ; frequencies
  126.                       '(0.6 0.2 (gen-sin 10 0.22 64) 0.2) ; amplitudes
  127.                       '(0 45 90) ; initial phases
  128.                       tempo-zone-len))
  129.  
  130. (setq chords
  131.     (symbols-to-tonality
  132.         symbols seedpat1
  133.         transpose '((0 2 3 4 6) (0 2 3 4 6) (0 2 3 4 6) (0 2 3 4 6) (0 2 3 4 6) (0 2 3 4 6)
  134.                     (0 2 4 6) (0 2 4 6) (0 2 4 6) (0 2 4 6) (0 2 4 6) (0 2 4 6))
  135.         mapping (activate-tonality (diminished2 c 3) (diminished2 c 3) (diminished2 c 3)
  136.                                    (diminished2 c 3) (diminished2 c 3) (diminished2 c 3)
  137.                                    (diminished1 g 2) (diminished1 g 2) (diminished1 g 2)
  138.                                    (diminished1 g 2) (diminished1 g 2) (diminished1 c 3))
  139.     )
  140. )
  141.  
  142. (def-section intro
  143.   default ; 24 bars
  144.     zone '(1/1 1/1 1/1 1/1  1/1 1/1 1/1 1/1  1/1 1/1 1/1 1/1
  145.            1/1 1/1 1/1 1/1  1/1 1/1 1/1 1/1  1/1 1/1 1/1 1/1)
  146.     tempo-zones (symbol-repeat 24 '(1/1))
  147.     tempo (vector-to-list (vector-round 93 100 (vector-quantize 12 24 (vector-mix tempomap1 tempomap2))))
  148.     length '(1/16)
  149.     velocity '(64)
  150.   righthand
  151.     tonality (symbol-repeat 2 chords)
  152.     symbol melody-1
  153.     channel 1 
  154.     length '((1/16) (1/2) (1/16) (1/2) (1/16) (1/2) (1/16) (1/2)
  155.              (1/16) (1/16) (1/8t) (1/8t)
  156.              (1/4) (1/4) (1/8t) (1/8t)  (1/4) (1/4) (1/8t) (1/8t)  (1/4) (1/4) (1/8t) (1/8t))
  157.     tuning (vector-to-list (vector-round -300 300 (gen-noise-white 128 1 0.39392)))
  158.     ;duration (vector-to-list (vector-round (get-tick '1/9) (get-tick '1/30) tempomap1))
  159.     velocity (vector-round 70 105 tempomap1)
  160.   lefthand
  161.     tonality (symbol-repeat 2 chords)
  162.     symbol melody-2
  163.     channel 2
  164.     length '((1/2) (1/16) (1/2) (1/16) (1/2) (1/16) (1/2) (1/16)
  165.              (1/16) (1/16) (1/8t) (1/8t)
  166.              (1/8t) (1/8t) (1/4) (1/4)  (1/8t) (1/8t) (1/4) (1/4)  (1/8t) (1/8t) (1/8t) (1/8t))
  167.     tuning (vector-to-list (vector-round -300 300 (gen-noise-white 128 1 0.29392)))
  168.     ;duration (vector-to-list (vector-round (get-tick '1/9) (get-tick '1/30) tempomap2))
  169.     velocity (vector-round 70 105 tempomap2)
  170.   3rd-voice
  171.     tonality (symbol-repeat 2 (activate-tonality (melodic-minor g 4) (major a 5) (melodic-minor d 4)))
  172.     channel 5 
  173.     length '(1/16)
  174.     symbol '(=)
  175.     velocity '(0)
  176. )
  177.  
  178. #| This is a comment
  179. (midiport :printer)
  180.  
  181. (play-file-p nil
  182.   piano '(intro prelude)
  183. )
  184. |#
  185.  
  186. ;;; part b
  187.  
  188. (setq seedpat1 (vector-to-symbol a h (vector-quantize 7 8 (vector-resynthesize 3 (gen-noise-white 256 1 0.121654921215454) nil t))))
  189. (setq seedpat2 (symbol-inversion 'e seedpat1))
  190. (setq seedpat3 (vector-to-symbol a h (vector-quantize 7 8 (vector-resynthesize 3 (gen-noise-white 256 1 0.2216549212115154) nil t))))
  191.  
  192. (mapcar #'symbol-to-integer seedpat1)
  193.  
  194. (setq transpat (mapcar #'symbol-to-integer seedpat1))
  195. (setq transpat2 (mapcar #'symbol-to-integer seedpat2))
  196. (setq transpat3 (mapcar #'symbol-to-integer seedpat3))
  197.  
  198. (setq theme-source 
  199.       (make-tr-melody seedpat1 1 transpat 0))
  200.  
  201. (setq theme theme-source)
  202.  
  203. (setq melody-1-source 
  204.       (append theme 
  205.               (symbol-transpose 8 
  206.                                 (symbol-inversion 'a theme))))
  207.  
  208. (setq melody-2-source  
  209.       (symbol-transpose 11 
  210.                         (symbol-shift (/ (length theme) 1) 
  211.                                       melody-1-source)))
  212.  
  213. (setq len2 (append (symbol-repeat 4 '(1/8 1/8 1/8 1/8))
  214.                    (symbol-repeat 2 '(1/16 1/16 1/16 1/16))
  215.                    (symbol-repeat 2 '(1/8 1/8 1/8 1/8))
  216.                    (symbol-repeat 2 '(1/16 1/16 1/16 1/16))
  217.                    (symbol-repeat 2 '(1/8 1/8 1/8 1/8))))
  218.  
  219. (setq len1 (append (symbol-repeat 4 '(1/8 1/8 1/8 1/8))
  220.                    (symbol-repeat 2 '(1/16 1/16 1/16 1/16))
  221.                    (symbol-repeat 2 '(1/8 1/8 1/8 1/8))
  222.                    (symbol-repeat 2 '(1/16 1/16 1/16 1/16))
  223.                    (symbol-repeat 2 '(1/8 1/8 1/8 1/8))))
  224.  
  225. (multiple-value-setq (hmel1 hmel2)
  226.       (len-harmonize2 melody-1-source len1 
  227.                      melody-2-source len2 
  228.                      12
  229.                      '32/1
  230.                      (activate-tonality (harmonic-minor c 2))
  231.                      '((4 2))
  232.                      '((1 2 3 6 8 9 10 11))))
  233.  
  234. (setq len2 (append '(-1/16) (symbol-trim 96 len2)))
  235.  
  236. (setq melody-1-mat (symbol-fold 14 7 (filter-deactivate 2 30 (find-change hmel1))))
  237. (setq melody-2-mat (symbol-fold 14 7 (filter-deactivate 2 30 (find-change hmel2))))
  238.  
  239. (setq melody-1 melody-1-mat)
  240. (setq melody-2 melody-2-mat)
  241.  
  242. (def-section prelude
  243.   default
  244.     zone '(32/1)
  245.     tempo-zones (symbol-trim (* 2 tempo-zone-len) '(1/8))
  246.     tempo       (append (vector-to-list (vector-round 70 85 tempomap1))
  247.                         (vector-to-list (vector-round 70 85 tempomap1)))
  248.     tonality (activate-tonality (harmonic-minor a 3))
  249.   lefthand
  250.     channel 3 
  251.     symbol melody-1
  252.     length len1
  253.     tonality (activate-tonality (harmonic-minor a 3))
  254.     velocity (symbol-to-velocity 65 110 3 (symbol-repeat 4 theme))
  255.     tuning (vector-to-list (vector-round -200 200 (gen-noise-white 128 1 0.18152212)))
  256.   righthand
  257.     channel 4 
  258.     symbol melody-2
  259.     length len2
  260.     velocity (symbol-to-velocity 65 110 3 (reverse (symbol-repeat 4 theme)))
  261.     tuning (vector-to-list (vector-round -200 200 (gen-noise-white 128 1 0.28152212)))
  262.   3rd-voice
  263.     tonality (symbol-repeat 2 (activate-tonality (melodic-minor g 4)))
  264.     channel 5 
  265.     length '(1/16)
  266.     symbol '(=)
  267.     velocity '(0)
  268. )
  269.  
  270. (play-file-p nil
  271.   piano '(intro prelude)
  272. )
  273.